home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / boolean.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-17  |  3.4 KB  |  122 lines
  1. /*
  2.  *
  3.  * b o o l e a n . c            -- Booleans and Equivalence predicates
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 23-Oct-1993 21:37
  22.  * Last file update: 19-Apr-1996 23:13
  23.  */
  24.  
  25. #include "stk.h"
  26. #include "extend.h"
  27.  
  28. PRIMITIVE STk_not(SCM x)
  29. {
  30.   return EQ(x, Ntruth) ? Truth : Ntruth;
  31. }
  32.  
  33. PRIMITIVE STk_booleanp(SCM x)
  34. {
  35.   return BOOLEANP(x) ? Truth: Ntruth;
  36. }
  37.  
  38. PRIMITIVE STk_eq(SCM x,SCM y)
  39. {
  40.   return EQ(x,y) ? Truth : Ntruth;
  41. }
  42.  
  43. PRIMITIVE STk_eqv(SCM x, SCM y)
  44. {
  45.   if (EQ(x,y)) return(Truth);
  46.  
  47.   switch (TYPE(x)) {
  48.     case tc_symbol: if (SYMBOLP(y) && strcmp(PNAME(x), PNAME(y)) == 0)
  49.                     return Truth;
  50.                 break;
  51.     case tc_integer:
  52.     case tc_flonum:
  53.     case tc_bignum: if (NUMBERP(y)) {
  54.                     if ((EXACTP(x) && FLONUMP(y)) || (FLONUMP(x) && EXACTP(y))) 
  55.             return Ntruth;
  56.               return (STk_equal_numbers(x,  y)) ? Truth : Ntruth;
  57.                 }
  58.                 break;
  59. #ifndef COMPACT_SMALL_CST
  60.     case tc_char:   if (CHARP(y) && CHAR(x) == CHAR(y)) return Truth;
  61.             break;
  62. #endif              
  63.     case tc_keyword: if (KEYWORDP(y) && strcmp(KEYVAL(x), KEYVAL(y)) == 0)
  64.                    return Truth;
  65.                  break;
  66. #ifdef USE_STKLOS
  67.     case tc_instance: {
  68.                   SCM fct = VCELL(STk_intern("object-eqv?"));
  69.             /* Test for UNBOUND, cause gf are not defined during boot */
  70.             return (fct == UNBOUND) ? Ntruth : Apply(fct, LIST2(x, y));
  71.                   }
  72. #endif
  73.     default:          if (EXTENDEDP(x) && EXTENDEDP(y) && TYPE(x) == TYPE(y)) 
  74.                   return STk_extended_compare(x, y, FALSE);
  75.   }
  76.   /* What can we do else? */
  77.   return Ntruth;
  78. }
  79.  
  80.  
  81. PRIMITIVE STk_equal(SCM x, SCM y)
  82. {
  83. Top:
  84.   if (STk_eqv(x, y) == Truth) return Truth;
  85.  
  86.   switch (TYPE(x)) {
  87.     case tc_cons:   if (CONSP(y)) {
  88.                     if (STk_equal(CAR(x), CAR(y)) == Ntruth) return Ntruth;
  89.               x = CDR(x); y = CDR(y);
  90.               goto Top;
  91.             }
  92.             break;
  93.     case tc_string: if (STRINGP(y)) 
  94.                       return (strcmp(CHARS(x), CHARS(y))==0) ? Truth: Ntruth;
  95.                     break;
  96.     case tc_vector: if (VECTORP(y)) {
  97.                     long lx, ly, i;
  98.               SCM *vx, *vy;
  99.               
  100.               lx = VECTSIZE(x); ly = VECTSIZE(y);
  101.                if (lx != ly) return Ntruth;
  102.  
  103.               for (i=0, vx=VECT(x), vy=VECT(y); i < lx;  i++)
  104.             if (STk_equal(vx[i], vy[i]) == Ntruth) return Ntruth;
  105.               return Truth;
  106.                 }
  107.                 break;
  108. #ifdef USE_STKLOS
  109.     case tc_instance: {
  110.                   SCM fct = VCELL(STk_intern("object-equal?"));
  111.             /* Test for UNBOUND, cause gf are not defined during boot */
  112.             return (fct == UNBOUND) ? Ntruth :  Apply(fct, LIST2(x, y));
  113.                   }
  114. #endif
  115.     default:        if (EXTENDEDP(x) && EXTENDEDP(y) && TYPE(x) == TYPE(y)) 
  116.                     return STk_extended_compare(x, y, TRUE);
  117.   }
  118.   return Ntruth;
  119. }
  120.  
  121.  
  122.